(module test-bag mzscheme

  (require "../private/require.ss")
  (require-contracts)
  (require-schemeunit)
  (require-etc)
  (require-lists)

  (require (lib "11.ss" "srfi")
           "../private/datum.ss"
           (prefix bag: "../bag.ss"))

  (provide/contract
   [test-bag schemeunit-test-suite?]
   [test-ordered-bag schemeunit-test-suite?]
   [test-hashed-bag schemeunit-test-suite?]
   [test-unordered-bag schemeunit-test-suite?])
  
  ;; we use this so that we can utilize datum-bindings=? and avoid
  ;; questions of whether the alist is ordered or not
  (define (alist->sexp alist)
    (map (lambda (p)
           (list (car p) (cdr p)))
         alist))

  (define (make-bag-test name bag)
    (test-suite (format "Bag: ~a" name)
      (test-suite "accessors"
        (test-suite "elements"
          (test-case "empty"
            (check datum-list=? (bag:elements (bag)) null))
          (test-case "1,2,3"
            (check datum-list=? (bag:elements (bag 1 2 3)) (list 1 2 3)))
          (test-case "1,2,2,3"
            (check datum-list=? (bag:elements (bag 1 2 2 3)) (list 1 2 3))))
        (test-suite "to-sexp"
          (test-case "empty"
            (check datum-bindings=?
                    (bag:to-sexp (bag))
                    null))
          (test-case "1,2,3"
            (check datum-bindings=?
                    (bag:to-sexp (bag 1 2 3))
                    (list (list 1 1)
                          (list 2 1)
                          (list 3 1))))
          (test-case "1,2,2,3"
            (check datum-bindings=?
                    (bag:to-sexp (bag 1 2 2 3))
                    (list (list 1 1)
                          (list 2 2)
                          (list 3 1)))))
        (test-suite "to-alist"
          (test-case "empty"
            (check datum-bindings=?
                    (alist->sexp (bag:to-alist (bag)))
                    null))
          (test-case "1,2,3"
            (check datum-bindings=?
                    (alist->sexp (bag:to-alist (bag 1 2 3)))
                    (list (list 1 1)
                          (list 2 1)
                          (list 3 1))))
          (test-case "1,2,2,3"
            (check datum-bindings=?
                    (alist->sexp (bag:to-alist (bag 1 2 2 3)))
                    (list (list 1 1)
                          (list 2 2)
                          (list 3 1)))))
        (test-suite "empty?"
          (test-case "true"
            (check-true (bag:empty? (bag))))
          (test-case "false"
            (check-false (bag:empty? (bag 1 2 3)))))
        (test-suite "size"
          (test-case "empty"
            (check = (bag:size (bag)) 0))
          (test-case "1,2,3"
            (check = (bag:size (bag 1 2 3)) 3))
          (test-case "1,2,2,3"
            (check = (bag:size (bag 1 2 2 3)) 4)))
        (test-suite "size/unique"
          (test-case "empty"
            (check = (bag:size/unique (bag)) 0))
          (test-case "1,2,3"
            (check = (bag:size/unique (bag 1 2 3)) 3))
          (test-case "1,2,2,3"
            (check = (bag:size/unique (bag 1 2 2 3)) 3)))
        (test-suite "member?"
          (test-case "true"
            (check-true (bag:member? 2 (bag 1 2 3))))
          (test-case "false"
            (check-false (bag:member? 4 (bag 1 2 3)))))
        (test-suite "count"
          (test-case "1,2,2,3,4,4,4"
            (let ([new-bag (bag 1 2 2 3 4 4 4)])
              (check = (bag:count 1 new-bag) 1)
              (check = (bag:count 2 new-bag) 2)
              (check = (bag:count 3 new-bag) 1)
              (check = (bag:count 4 new-bag) 3))))
        (test-suite "lookup"
          (test-case "a in a,b,c"
            (check datum=?
                    (bag:lookup "a" (bag "a" "b" "c"))
                    "a"))
          (test-case "a in b,c"
            (check-false (bag:lookup "a" (bag "b" "c"))))
          (test-case "success override"
            (check-equal?
             (bag:lookup 1 (bag 1 2 3)
                         (lambda () 'failure)
                         (lambda (elem) (list 'success elem)))
             (list 'success 1)))
          (test-case "failure override"
            (check-equal?
             (bag:lookup 4 (bag 1 2 3)
                         (lambda () 'failure)
                         (lambda (elem) (list 'success elem)))
             'failure)))
        (test-suite "lookup/count"
          (test-case "a in a,b,c"
            (check datum=?
                    (bag:lookup/count "a" (bag "a" "b" "c"))
                    "a"))
          (test-case "a in b,c"
            (check-false (bag:lookup/count "a" (bag "b" "c"))))
          (test-case "success override"
            (check-equal?
             (bag:lookup/count 1 (bag 1 2 3)
                               (lambda () 'failure)
                               (lambda (elem count) (list 'success elem count)))
             (list 'success 1 1)))
          (test-case "failure override"
            (check-equal?
             (bag:lookup/count 4 (bag 1 2 3)
                               (lambda () 'failure)
                               (lambda (elem count) (list 'success elem count)))
             'failure)))
        (test-suite "select"
          (test-case "select from 1 2 3"
            (let ([new-bag (bag 1 2 3)])
              (check-true (bag:member? (bag:select new-bag) new-bag)))))
        (test-suite "select/count"
          (test-case "select from 1 2 3"
            (let*-values ([(new-bag) (bag 1 2 3)]
                          [(elem count) (bag:select/count new-bag)])
              (check-true (bag:member? elem new-bag))
              (check-true (= (bag:count elem new-bag) count)))))
        )
      (test-suite "updaters"
        (test-suite "insert"
          (test-case "1,3 + 2"
            (check datum-list=?
                    (bag:elements (bag:insert 2 (bag 1 3)))
                    (list 1 2 3)))
          (test-case "1,2,3 + 2"
            (let* ([new-bag (bag:insert 2 (bag 1 2 3))]
                   [elems (bag:elements new-bag)])
              (check datum-list=? elems (list 1 2 3))
              (check = (bag:count 2 new-bag) 2
                      "Inserting the element did not change the element count.")))
          (test-case "a + a"
            (let* ([a "a"]
                   [a* (string-copy a)]
                   [new-bag (bag:insert a* (bag a))]
                   [elems (bag:elements new-bag)])
              (check = (length elems) 1
                      "Inserting a duplicate changed set size.")
              (check = (bag:count a* new-bag) 2
                      "Inserting a duplicate did not change the element count.")
              (check-false
               (eq? (first elems) a)
               "Inserted duplicate; original value remains.")
              (check-true
               (eq? (first elems) a*)
               "Inserted duplicate; new value not found."))))
        (test-suite "insert/count"
          (test-case "1,3 + 2 * 2"
            (check datum-bindings=?
                    (bag:to-sexp (bag:insert/count 2 2 (bag 1 3)))
                    (list (list 1 1)
                          (list 2 2)
                          (list 3 1))))
          (test-case "1,2,3 + 2 * 2"
            (let* ([new-bag (bag:insert/count 2 2 (bag 1 2 3))]
                   [elems (bag:elements new-bag)])
              (check datum-list=? elems (list 1 2 3))
              (check = (bag:count 2 new-bag) 3
                      "Inserting the element did not change the element count.")))
          (test-case "a + a * 3"
            (let* ([a "a"]
                   [a* (string-copy a)]
                   [new-bag (bag:insert/count a* 3 (bag a))]
                   [elems (bag:elements new-bag)])
              (check = (length elems) 1
                      "Inserting a duplicate changed set size.")
              (check = (bag:count a* new-bag) 4
                      "Inserting a duplicate did not change the element count.")
              (check-false
               (eq? (first elems) a)
               "Inserted duplicate; original value remains.")
              (check-true
               (eq? (first elems) a*)
               "Inserted duplicate; new value not found."))))
        (test-suite "remove"
          (test-case "present"
            (check datum-list=?
                    (bag:elements (bag:remove 2 (bag 1 2 3)))
                    (list 1 3))
            (let* ([old-bag (bag 1 2 2 3)]
                   [new-bag (bag:remove 2 old-bag)])
              (check datum-list=?
                      (bag:elements new-bag)
                      (list 1 2 3))
              (check = (bag:count 2 old-bag) 2)
              (check = (bag:count 2 new-bag) 1)))
          (test-case "absent"
            (check datum-list=?
                    (bag:elements (bag:remove 4 (bag 1 2 3)))
                    (list 1 2 3))))
        (test-suite "remove/count"
          (test-case "present"
            (check datum-list=?
                    (bag:elements (bag:remove/count 2 4 (bag 1 2 2 2 2 3)))
                    (list 1 3))
            (let* ([old-bag (bag 1 2 2 2 3)]
                   [new-bag (bag:remove/count 2 2 old-bag)])
              (check datum-list=?
                      (bag:elements new-bag)
                      (list 1 2 3))
              (check = (bag:count 2 old-bag) 3)
              (check = (bag:count 2 new-bag) 1)))
          (test-case "absent"
            (check datum-list=?
                    (bag:elements (bag:remove/count 4 3 (bag 1 2 3)))
                    (list 1 2 3))))
        (test-suite "remove*"
          (test-case "present"
            (check datum-list=?
                    (bag:elements (bag:remove* (bag 1 2 3) 2))
                    (list 1 3))
            (let* ([old-bag (bag 1 2 2 3)]
                   [new-bag (bag:remove* old-bag 1 2)])
              (check datum-list=?
                      (bag:elements new-bag)
                      (list 2 3))
              (check = (bag:count 2 old-bag) 2)
              (check = (bag:count 2 new-bag) 1)))
          (test-case "absent"
            (check datum-list=?
                    (bag:elements (bag:remove* (bag 1 2 3) 4 5))
                    (list 1 2 3))))
        (test-suite "remove/all"
          (test-case "present"
            (check datum-list=?
                    (bag:elements (bag:remove/all 2 (bag 1 2 3)))
                    (list 1 3))
            (check datum-list=?
                    (bag:elements (bag:remove/all 2 (bag 1 2 2 3)))
                    (list 1 3)))
          (test-case "absent"
            (check datum-list=?
                    (bag:elements (bag:remove/all 4 (bag 1 2 3)))
                    (list 1 2 3))))
        (test-suite "clear"
          (test-case "1,2,3"
            (let* ([old-bag (bag 1 2 3)]
                   [new-bag (bag:clear old-bag)])
              (check-false (bag:empty? old-bag))
              (check-true (bag:empty? new-bag)))))
        )
      (test-suite "traversals"
        (test-suite "fold"
          (test-case "1,2,2,3"
            (check datum-list=?
                    (bag:fold (lambda (e l)
                                (cons e l))
                              null
                              (bag 1 2 2 3))
                    (list 1 2 3))))
        (test-suite "fold/count"
          (test-case "1,2,2,3"
            (check datum-bindings=?
                    (bag:fold/count (lambda (e c l)
                                      (cons (list e c) l))
                                    null
                                    (bag 1 2 2 3))
                    (list (list 1 1) (list 2 2) (list 3 1)))))
        (test-suite "map"
          (test-case "1,2,2,3"
            (check datum-bindings=?
                    (bag:to-sexp (bag:map (lambda (e) (+ e 3))
                                          (bag 1 2 2 3)))
                    (list (list 4 1) (list 5 2) (list 6 1)))))
        (test-suite "map/count"
          (test-case "1,2,2,3"
            (check datum-bindings=?
                    (bag:to-sexp (bag:map/count (lambda (e c) (+ e c))
                                                (bag 1 2 2 3)))
                    (list (list 2 1) (list 4 3)))))
        (test-suite "for-each"
          (test-case "1,2,2,3"
            (let* ([elems null])
              (bag:for-each (lambda (e)
                              (set! elems (cons e elems)))
                            (bag 1 2 2 3))
              (check datum-list=?
                      elems
                      (list 1 2 3))))
          (test-case "non-void"
            (bag:for-each (constant #f) (bag 1 2 3))))
        (test-suite "for-each/count"
          (test-case "1,2,2,3"
            (let* ([elems null])
              (bag:for-each/count (lambda (e c)
                                    (set! elems (cons (list e c) elems)))
                                  (bag 1 2 2 3))
              (check datum-bindings=?
                      elems
                      (list (list 1 1) (list 2 2) (list 3 1)))))
          (test-case "non-void"
            (bag:for-each (constant #f) (bag 1 2 3))))
        (test-suite "filter"
          (test-case "numbers"
            (check datum-list=?
                    (bag:elements (bag:filter number?
                                              (bag 1 2 3 'a 'b 'c "A" "B" "C")))
                    (list 1 2 3))))
        (test-suite "filter/count"
          (test-case "count > 1"
            (check datum-list=?
                    (bag:elements (bag:filter/count (lambda (e c) (> c 1))
                                                    (bag 1 2 3 'a 'b 'c "A" "B" "C" 1 2 3)))
                    (list 1 2 3))))
        (test-suite "all?"
          (test-case "all"
            (check-true (bag:all? number? (bag 1 2 3 4))))
          (test-case "some"
            (check-false (bag:all? even? (bag 1 2 3 4))))
          (test-case "none"
            (check-false (bag:all? negative? (bag 1 2 3 4)))))
        (test-suite "any?"
          (test-case "all"
            (check-true (bag:any? number? (bag 1 2 3 4))))
          (test-case "some"
            (check-true (bag:any? even? (bag 1 2 3 4))))
          (test-case "none"
            (check-false (bag:any? negative? (bag 1 2 3 4)))))
        (test-suite "all?/count"
          (test-case "all"
            (check-true (bag:all?/count (lambda (e c) (> c 1))
                                         (bag 1 1 2 2 2 3 3 4 4 4 4))))
          (test-case "some"
            (check-false (bag:all?/count (lambda (e c) (> c 2))
                                          (bag 1 1 2 2 2 3 3 4 4 4 4))))
          (test-case "none"
            (check-false (bag:all?/count (lambda (e c) (> c 4))
                                          (bag 1 1 2 2 2 3 3 4 4 4 4)))))
        (test-suite "any?/count"
          (test-case "all"
            (check-true (bag:any?/count (lambda (e c) (> c 1))
                                         (bag 1 1 2 2 2 3 3 4 4 4 4))))
          (test-case "some"
            (check-true (bag:any?/count (lambda (e c) (> c 2))
                                         (bag 1 1 2 2 2 3 3 4 4 4 4))))
          (test-case "none"
            (check-false (bag:any?/count (lambda (e c) (> c 4))
                                          (bag 1 1 2 2 2 3 3 4 4 4 4)))))
        )
      (test-suite "combinations"
        (test-suite "union"
          (test-suite "idempotent"
            (test-case "b1 union b1 = b1"
              (let ([b1 (bag 1 2 3 2 3 4)])
                (check bag:equal?
                        (bag:union b1 b1)
                        b1))))
          (test-suite "commutative"
            (test-case "b1 union b2 = b2 union b1"
              (let ([b1 (bag 1 2 2 3 3 4)]
                    [b2 (bag 2 2 3 3 3 5)])
                (check bag:equal?
                        (bag:union b1 b2)
                        (bag:union b2 b1))))
            (test-case "b1 union b2 = b3"
              (let ([b1 (bag 1 2 2 3 3 4)]
                    [b2 (bag 2 2 3 3 3 5)]
                    [b3 (bag 1 2 2 3 3 3 4 5)])
                (check bag:equal?
                        (bag:union b1 b2)
                        b3))))
          (test-suite "associative"
            (test-case "(b1 union b2) union b4 = b1 union (b2 union b4)"
              (let ([b1 (bag 1 2 2 3 3 4)]
                    [b2 (bag 2 2 3 3 3 5)]
                    [b4 (bag 2 3 4 5 6)])
                (check bag:equal?
                        (bag:union (bag:union b1 b2) b4)
                        (bag:union b1 (bag:union b2 b4)))))
            (test-case "(b1 union b2) union b4 = b5"
              (let ([b1 (bag 1 2 2 3 3 4)]
                    [b2 (bag 2 2 3 3 3 5)]
                    [b4 (bag 2 3 4 5 6)]
                    [b5 (bag 1 2 2 3 3 3 4 5 6)])
                (check bag:equal?
                        (bag:union (bag:union b1 b2) b4)
                        b5)))))
        (test-suite "intersection"
          (test-suite "idempotent"
            (test-case "b1 union b1 = b1"
              (let ([b1 (bag 1 2 3 2 3 4)])
                (check bag:equal?
                        (bag:intersection b1 b1)
                        b1))))
          (test-suite "commutative"
            (test-case "b1 union b2 = b2 union b1"
              (let ([b1 (bag 1 2 2 3 3 4)]
                    [b2 (bag 2 2 3 3 3 5)])
                (check bag:equal?
                        (bag:intersection b1 b2)
                        (bag:intersection b2 b1))))
            (test-case "b1 union b2 = b3"
              (let ([b1 (bag 1 2 2 3 3 4)]
                    [b2 (bag 2 2 3 3 3 5)]
                    [b3 (bag 2 2 3 3)])
                (check bag:equal?
                        (bag:intersection b1 b2)
                        b3))))
          (test-suite "associative"
            (test-case "(b1 union b2) union b4 = b1 union (b2 union b4)"
              (let ([b1 (bag 1 2 2 3 3 4)]
                    [b2 (bag 2 2 3 3 3 5)]
                    [b4 (bag 2 3 4 5 6)])
                (check bag:equal?
                        (bag:intersection (bag:intersection b1 b2) b4)
                        (bag:intersection b1 (bag:intersection b2 b4)))))
            (test-case "(b1 union b2) union b4 = b5"
              (let ([b1 (bag 1 2 2 3 3 4)]
                    [b2 (bag 2 2 3 3 3 5)]
                    [b4 (bag 2 3 4 5 6)]
                    [b5 (bag 2 3)])
                (check bag:equal?
                        (bag:intersection (bag:intersection b1 b2) b4)
                        b5)))))
        (test-suite "difference"
          (test-case "b1 difference b1 = (empty)"
            (let ([b1 (bag 1 2 3 2 3 4)])
              (check bag:equal?
                      (bag:difference b1 b1)
                      (bag:clear b1))))
          (test-case "b1 difference b2 = b3"
            (let ([b1 (bag 1 2 2 3 3 4)]
                  [b2 (bag 2 2 3 3 3 5)]
                  [b3 (bag 1 4)])
              (check bag:equal?
                      (bag:difference b1 b2)
                      b3)))
          (test-case "(b1 difference b2) difference b4 = b5"
            (let ([b1 (bag 1 2 2 3 3 4)]
                  [b2 (bag 2 2 3 3 3 5)]
                  [b4 (bag 2 3 4 5 6)]
                  [b5 (bag 1)])
              (check bag:equal?
                      (bag:difference (bag:difference b1 b2) b4)
                      b5))))
        )
      (test-suite "relations"
        (test-suite "subbag?"
          (test-case "true"
            (check-true (bag:subbag? (bag 1 2 3) (bag 1 2 2 3))))
          (test-case "false"
            (check-false (bag:subbag? (bag 4 4 5 6 6 6) (bag 4 5 6 6)))))
        (test-suite "equal?"
          (test-case "true"
            (check-true (bag:equal? (bag 1 2 2 3) (bag 1 2 2 3))))
          (test-case "false"
            (check-false (bag:equal? (bag 1 2 2 3) (bag 1 2 3)))))
        )
    ))

  (define test-ordered-bag
    (make-bag-test "Ordered" (curry bag:make-ordered datum-compare)))

  (define test-hashed-bag
    (make-bag-test "Hashed" (curry bag:make-hashed datum-hash datum=?)))

  (define test-unordered-bag
    (make-bag-test "Unordered" (curry bag:make-unordered datum=?)))

  (define test-bag
    (test-suite "Bags"
      test-ordered-bag
      test-hashed-bag
      test-unordered-bag))

  )